perm filename LISP.LSP[1,3]4 blob
sn#332473 filedate 1978-02-08 generic text, type T, neo UTF8
(DEFPROP %DEFIN
(LAMBDA (X V F P)
(PROG (R)
(SETQ R (COND ((GETL X %FTYPES) (LIST X (QUOTE REDEFINED))) (T X)))
(PUTPROP X (LIST (QUOTE LAMBDA) V F) P)
(RETURN R)))
EXPR)
(DEFPROP %DEF
(LAMBDA (ARGS TYPE)
(COND ((ATOM (CAR ARGS))
(%DEFIN (CAR ARGS)
(CADR ARGS)
(CADDR ARGS)
(COND ((NULL (CDDDR ARGS)) TYPE) (T (CADDDR ARGS)))))
(T (%DEFIN (CAAR ARGS)
(CDAR ARGS)
(CADR ARGS)
(COND ((NULL (CDDR ARGS)) TYPE) (T (CADDR ARGS)))))))
EXPR)
(DEFPROP DE (LAMBDA (L) (%DEF L (QUOTE EXPR))) FEXPR)
(DEFPROP DF (LAMBDA (L) (%DEF L (QUOTE FEXPR))) FEXPR)
(DEFPROP DM (LAMBDA (L) (%DEF L (QUOTE MACRO))) FEXPR)
(SETQ %FTYPES (QUOTE (EXPR FEXPR SUBR FSUBR LSUBR MACRO)))
(DEFPROP PLUS (LAMBDA (L) (*EXPAND L (QUOTE *PLUS))) MACRO)
(DEFPROP DIFFERENCE (LAMBDA (L) (*EXPAND L (QUOTE *DIF))) MACRO)
(DEFPROP TIMES (LAMBDA (L) (*EXPAND L (QUOTE *TIMES))) MACRO)
(DEFPROP QUOTIENT (LAMBDA (L) (*EXPAND L (QUOTE *QUO))) MACRO)
(DEFPROP LESSP
(LAMBDA (L)
(LIST (QUOTE *LESS)
(*EXPAND1 (CDR (REVERSE (CDR L)))
(QUOTE (LAMBDA (X Y) (COND ((AND X (*LESS X Y)) Y)))))
(CAR (LAST L))))
MACRO)
(DEFPROP GREATERP
(LAMBDA (L)
(LIST (QUOTE *GREAT)
(*EXPAND1 (CDR (REVERSE (CDR L)))
(QUOTE (LAMBDA (X Y) (COND ((AND X (*GREAT X Y)) Y)))))
(CAR (LAST L))))
MACRO)
(DEFPROP %DEVP
(LAMBDA (X)
(OR (EQ (CAR (LAST (EXPLODE X))) (QUOTE :))
(AND (NOT (ATOM X)) (NOT (ATOM (CDR X))))))
EXPR)
(DE %READCHAN (%CHAN %TALK)
(PROG (%OLDCHAN %SEXPR)
(SETQ %OLDCHAN (INC %CHAN NIL))
LOOP (SETQ %SEXPR (ERRSET (READ)))
(COND ((EQ (CAR %SEXPR) (QUOTE COMMENT))
(PROG (%XCH)
A (SETQ %XCH (READCH))
(AND (EQ %XCH (QUOTE ;)) (RETURN))
(GO A))
(GO LOOP)))
(COND ((ATOM %SEXPR) (GO END)))
(SETQ %SEXPR (EVAL (CAR %SEXPR)))
(COND (%TALK (PRINT %SEXPR)))
(GO LOOP)
END (INC %OLDCHAN T)
(RETURN NIL)))
(DE %READAFILE (%DEV %FNAM %TALK)
(%READCHAN (EVAL (LIST (QUOTE INPUT) (GENSYM) %DEV %FNAM)) %TALK))
(DE READIN (%DEV %FLIST %TALK)
(PROG NIL
LOOP (COND ((NULL %FLIST) (RETURN (QUOTE FINISHED-LOADING)))
((%DEVP (CAR %FLIST)) (SETQ %DEV (CAR %FLIST))
(SETQ %FLIST (CDR %FLIST))
(GO LOOP)))
(%READAFILE %DEV (CAR %FLIST) %TALK)
(SETQ %FLIST (CDR %FLIST))
(GO LOOP)))
(DF DSKIN (%L) (READIN (QUOTE DSK:) %L T))
(DF SYSIN (%L) (READIN (QUOTE SYS:) %L NIL))
(DEFPROP PUTSYM
(LAMBDA (L)
(MAPCAR (FUNCTION (LAMBDA (X)
(COND ((ATOM X) (*PUTSYM X X))
(T (*PUTSYM (CAR X) (EVAL (CADR X)))))))
L))
FEXPR)
(DEFPROP GETSYM
(LAMBDA (L)
(MAPCAR (FUNCTION (LAMBDA (X)
(PROG (V)
(SETQ V (*GETSYM X))
(COND (V (PUTPROP X (NUMVAL V) (CAR L)))
(T (PRINT (CONS X
(QUOTE (NOT IN
SYMBOL
TABLE))))))
(RETURN V))))
(CDR L)))
FEXPR)
(DF BREAK (%LL%)
(PROG (%EX% %ICH% %OCH%)
(SETQ %ICH% (INC NIL NIL))
(SETQ %OCH% (OUTC NIL NIL))
(PRINT (CONS (QUOTE *BREAK*) (CAR %LL%)))
LOOP (TERPRI)
(SETQ %EX% (ERRSET (READ)))
(COND ((ATOM %EX%) (GO LOOP)))
(COND ((EQ (CAR %EX%) *BPROCEED*) (GO END)))
(ERRSET (PRIN1 (EVAL (CAR %EX%))))
(GO LOOP)
END (INC %ICH% NIL)
(OUTC %OCH% NIL)
(RETURN (EVAL (CADR %LL%)))))
(SETQ *BPROCEED* (QUOTE P))
(PROG (EX)
(SETQ EX (QUOTE (LAMBDA (L)
(PROG2 (SYSIN LAP) (LIST (QUOTE QUOTE) (EVAL L))))))
(MAPC (FUNCTION (LAMBDA (X) (PUTPROP X EX (QUOTE MACRO))))
(QUOTE (DEFSYM LAP OPS))))
(PROG (EX)
(SETQ EX (QUOTE (LAMBDA (L)
(PROG2 (SYSIN (SOSLNK . LAP))
(LIST (QUOTE QUOTE) (EVAL L))))))
(MAPC (FUNCTION (LAMBDA (X) (PUTPROP X EX (QUOTE MACRO))))
(QUOTE (EDFUN FILEIN))))
(PROG (EX)
(SETQ EX (QUOTE (LAMBDA (L)
(PROG2 (SYSIN TRACE) (LIST (QUOTE QUOTE) (EVAL L))))))
(MAPC (FUNCTION (LAMBDA (X) (PUTPROP X EX (QUOTE MACRO))))
(QUOTE (TRACE UNTRACE TRACET UNTRACET SLST UNSLST RESET))))
(DF COMMENT (L) NIL)
(DF DECLARE (L) NIL)
(SETQ EIGHT (ADD1 7))
(SETQ TEN (PLUS 2 EIGHT))
(DE OCTAL NIL (SETQ BASE (SETQ IBASE EIGHT)))
(DE DECIMAL NIL (SETQ BASE (SETQ IBASE TEN)))
(COND ((NULL (ERRSET (INPUT INITCHAN DSK: (LISP . INI)) NIL)))
(T (%READCHAN (QUOTE INITCHAN) NIL)))
(PROG NIL (INC NIL T) (OUTC NIL T) (EXCISE) (CSYM G0000) (ERR))